
#|This defproto appears in hom-main.lsp

(defproto homals-proto  '(data-matrix n m z y d-m k-j-list row-ind-list col-ind-list dlist  p active-categories active-homals-variables sample-row-ind-list sample-col-ind-list weights weights-samp dlist-samp z-list variable-labels object-labels category-labels itmax category-labels output-file dialog  eps-0 eps-1 active-categories-category lab label-object-by data-object) () analysis-plugin-object-proto )

|#

(defmeth homals-proto  :data-matrix              ; data matrix       
 (&optional (values nil set))
    (if set (setf (slot-value 'data-matrix) values))
    (slot-value 'data-matrix))

(defmeth homals-proto  :n                 ; number of objects
(&optional (values nil set))
    (if set (setf (slot-value 'n) values))
    (slot-value 'n))

(defmeth homals-proto  :m                 ; number of variables
(&optional (values nil set))
    (if set (setf (slot-value 'm) values))
    (slot-value 'm))

(defmeth homals-proto :z                 ;  (objects scores ¿?)
(&optional (values nil set))
    (if set (setf (slot-value 'z) values)) 
    (slot-value 'z))

(defmeth homals-proto :y                 ; (categories quantification ¿?)  
	(&optional (values nil set))
    (if set (setf (slot-value 'y) values))
    (slot-value 'y))

(defmeth homals-proto :d-m                ;  (discrimination measures ¿?)
	(&optional (values nil set))
    (if set (setf (slot-value 'd-m) values))
    (slot-value 'd-m))

(defmeth homals-proto :k-j-list            ; k categories of j variables list.  
	(&optional (values nil set))
    (if set (setf (slot-value 'k-j-list) values))
    (slot-value 'k-j-list))

(defmeth homals-proto :p                   ; computing dimensions 
	(&optional (values nil set))
    (if set (setf (slot-value 'p) values))
    (slot-value 'p))

(defmeth homals-proto :itmax                  ; computing dimensions 
	(&optional (values nil set))
    (if set (setf (slot-value 'itmax) values))
    (slot-value 'itmax))

(defmeth homals-proto :active-categories   ; list of active categories 
	(&optional (values nil set))
    (if set (setf (slot-value 'active-categories) values))
    (slot-value 'active-categories))

(defmeth homals-proto :active-homals-variables  ; list of active variables
	(&optional (values nil set))
    (if set (setf (slot-value 'active-homals-variables) values))
    (slot-value 'active-homals-variables))

(defmeth homals-proto :variable-labels  ; labels of all variables
	(&optional (values nil set))
    (if set (setf (slot-value 'variable-labels) values))
    (slot-value 'variable-labels))

(defmeth homals-proto :object-labels   ; 
	(&optional (values nil set))
    (if set (setf (slot-value 'object-labels) values))
    (slot-value 'object-labels))

(defmeth homals-proto :category-labels   ; 
	(&optional (values nil set))
    (if set (setf (slot-value 'category-labels) values))
    (slot-value 'category-labels))


(defmeth homals-proto :eps-0       ; function change
	(&optional (values nil set))
    (if set (setf (slot-value 'eps-0) values))
    (slot-value 'eps-0))

(defmeth homals-proto :eps-1        ; solution change
	(&optional (values nil set))
    (if set (setf (slot-value 'eps-1) values))
    (slot-value 'eps-1))

(defmeth homals-proto :row-ind-list        ; solution change
	(&optional (values nil set))
    (if set (setf (slot-value 'row-ind-list ) values))
    (slot-value 'row-ind-list   ))

(defmeth homals-proto :col-ind-list        ; solution change
	(&optional (values nil set))
    (if set (setf (slot-value 'col-ind-list) values))
    (slot-value 'col-ind-list))

(defmeth homals-proto :dlist        ; solution change
	(&optional (values nil set))
    (if set (setf (slot-value 'dlist) values))
    (slot-value 'dlist))

(defmeth homals-proto :weights        ; solution change
	(&optional (values nil set))
    (if set (setf (slot-value 'weights) values))
    (slot-value 'weights))

(defmeth homals-proto :weights-samp         ; solution change
	(&optional (values nil set))
    (if set (setf (slot-value 'weights-samp ) values))
    (slot-value 'weights-samp ))

(defmeth homals-proto :active-categories-category         ; categories
	(&optional (values nil set))
    (if set (setf (slot-value 'active-categories-category ) values))
    (slot-value 'active-categories-category ))


(defmeth homals-proto :data-object        ; data-object
	(&optional (values nil set))
    (if set (setf (slot-value 'data-object ) values))
    (slot-value 'data-object ))

(defmeth homals-proto :lab
	(&optional (values nil set))
    (if set (setf (slot-value 'lab) values))
    (slot-value 'lab ))

(defmeth homals-proto :label-object-by
	(&optional (values nil set))
    (if set (setf (slot-value 'label-object-by) values))
    (slot-value 'label-object-by ))



(defmeth homals-proto :options ()
  (setf text-dimensions (send edit-text-item-proto :new "5" :text-length 10))
  (setf text-iter (send edit-text-item-proto :new "100" :text-length 10))
  (setf text-change (send edit-text-item-proto :new "0.0001" :text-length 10))
  (setf text-function-change (send edit-text-item-proto :new "0.0001" :text-length 10))
  (setf text-lab (send edit-text-item-proto :new "Obs labels" :text-length 10))
  
  
  (setf OK (send modal-button-proto :new "Ok"
                 :action
               #'(lambda ()
                   (let (
                         (dialog (send ok :dialog))
                         )
                     
                     
                     (send self :p   (read-from-string (send text-dimensions :text)))              
                     (send self :itmax (read-from-string (send text-iter :text)))
                     (send self :eps-0 (read-from-string (send text-change :text)))
                     (send self :eps-1 (read-from-string (send text-function-change :text)))
                     (send self :lab  (send text-lab :text))
                     (send self :set-inds)
                     ))))
  
  
  (setf cancel (send modal-button-proto :new "Cancel"
                     :action
               #'(lambda ()
                   (let (
                         (dialog (send cancel :dialog))
                         )
                     (send dialog :modal-dialog-return nil) ))))
  
(setf vista-homals-dialog
      (send modal-dialog-proto :new
            (list (list "Dimensions      " text-dimensions)
                  (list "Iterations      " text-iter)
                  (list "Solution change " text-change)
                  (list "Function change " text-function-change)
                  (list "Label object by " text-lab)
                  (list ok cancel ))
			:default-button ok
))
(setf result (send vista-homals-dialog :modal-dialog))
             result)


(defmeth homals-proto :analysis ()
	(send self :compute)
   )

(defmeth homals-proto :compute 
  ( &key
    (data (send self :data-matrix))  
   	; data matrix PV changed was :data
    (ndim (send self :p))              ; # computing dimensions
    (active-variables                  ; list of active variables PV changed was :active-homals-variables
        (send self :active-homals-variables))
    (active-categories                 ; list of active categories
         (send self :active-categories))  ; for the active variables
    (object-labels                     ; labels of all objects
         (send self :object-labels))
    (variable-labels                   ; labels of all variables
          (send self :variable-labels))
    (category-labels                   ; labels of all categories
           (send self :category-labels))
    (eps-0 (send self :eps-0))         ; function change
    (eps-1 (send self :eps-1))         ; solution change
    (lab (send self :lab))
    
    (itmax (send self :itmax))         ; # iterations
    (qr t)   ; Q-R or Gram ?
    (speed t))                        ; Speed or Memory

#|Removed by PV. This was too slow and made my computer crash with non so big datasets

(setf label-object-by 
      (let* (
             (pos ($position (list (send self :lab)) 
                             (combine (list "obs labels")  (send current-data :variables))))
             (m (make-array (list  (+ 1 (send current-data :nvar)) (send current-data :nobs)) :initial-contents (list (combine  (send current-data :labels) (combine (transpose (send current-data :data-matrix)))))))
             (all-labels (combine (select (row-list m) pos)))
             (all-labels-string (to-string-list all-labels)))
        (setf selected-labels (select all-labels-string ($position (send current-data :active-labels) 
                                                                   (send current-data :labels))))))
  (send self :label-object-by label-object-by|#

  (send self :label-object-by 
        (let* (
               (pos (first ($position (list (send self :lab)) 
                               (combine (list "Obs labels")  (send (send self :data-object) :variables)))))
               (if pos pos 0)
               (type (if (= pos 0) 
                         "Category"
                         (select  (send (send self :data-object) :types) (1- pos))))
               )
          (if (equal type "Category")
              (if (= pos 0)
                  (send (send self :data-object) :active-labels)
                  (coerce 
                   (select 
                    (column-list (send (send self :data-object) :data-matrix)) 
                    (1- pos)) 'list))
              (mapcar #'princ-to-string ;if the column chosen is numerical it changes it to string
                      (coerce 
                       (select 
                        (column-list (send (send self :data-object) :data-matrix)) 
                        (1- pos)) 'list)))
          ))
                   

(let* (
       (lab (send self :lab))
       (n (send self :n))
       (e (select data (iseq n) active-variables))
       (m (length active-variables))
       (w (make-weights e active-categories))
       (x (make-random-orthonormal w n ndim m))
       (fit-0 0)
       (fit-1 0)
       (itel 0)
       h)

;; window for reporting iterations

    (setf ct (make-container :free t :type 2 :local-menus nil :show nil :title "Homals Report window"))
    (enable-container ct)
    (setf *homals-report-window* (send display-window-proto2 :new :pop-out nil))
  (disable-container)
    (send *homals-report-window* :size 400 300)
  (send ct :size 450 360)
  ;(send ct :close) ;a kludge to hide the container that appears
    (add-text *homals-report-window*
              (format nil "Homals iterations.~%Homals computation is an iterative process.~%The iteration history appears below.~%") 
              :scroll t)

  (send self :d-m nil)
  (send self :k-j-list nil)
  (if speed
      (dotimes (j m)
               (let ((g (make-indicator (elt (column-list e) j)
                                             (elt active-categories j))))
                 (setf h (append h (list g))))))
  (loop
   (let ((z (make-array (list n ndim) :initial-element 0))
         (new-fit-0 (* n ndim))
         (new-fit-1 0)
         )
     (dotimes (j m)
       (let* ((g (if speed (elt h j)
                     (make-indicator (elt (column-list e) j)
                                     (elt active-categories j))))
              (y (make-category-quantifications x g))
              (disc (* (/ n m) (make-discrimination-measures y g))))
         (if (= itel 0) (send self :k-j-list (array-dimension g 1)))
         (setf new-fit-0 (- new-fit-0 (sum (diagonal disc))))
         (setf z (+ z (matmult g y)))))
     (if qr
         (setf z (* (sqrt n)
                    (q-r-decomp (homals-center (apply #'bind-rows
                                            (* (geninv w) (row-list z))) w)
                                (/ w m))))
         (setf z (* (sqrt n)
                    (gram-schmidt (homals-center (apply #'bind-rows
                                            (* (geninv w) (row-list z))) w)
                                 (/ w m)))))
     (setf new-fit-1 (/ (sum (combine (matmult (transpose z)
                                      (apply #'bind-rows (* w (row-list x))))))
                        (* m n ndim)))
     (if (or (and (> eps-0 (abs (- new-fit-0 fit-0)))
                  (> eps-1 (abs (- new-fit-1 fit-1))))
             (> itel itmax))
         (progn
               (let ((bigy (repeat (list (list 0)) ndim))
                     (c (make-array (list ndim ndim) :initial-element 0)))
                 (dotimes (j m)
                   (let* ((g (if speed (elt h j)
                             (make-indicator (elt (column-list e) j)
                                             (elt active-categories j))))
                          (y (make-category-quantifications z g))
                          (d (make-discrimination-measures y g)))
                     (setf bigy (mapcar #'combine bigy (column-list y)))
                     (if qr (send self :d-m d))
                     (setf c (+ c d))))
                 (if qr 
                  (progn 
                   (send self :z z)
                   (send self :y (apply #'bind-columns
                                          (mapcar #'rest bigy))))
                  (progn               
                    (let* ((f (elt (eigen c) 1))
                           (k (apply #'bind-columns f)))
                     (send self :z (matmult z k))
                     (send self :y (matmult (apply #'bind-columns
                                            (mapcar #'rest bigy)) k))
                    (dotimes (j m)
                      (let* ((g (if speed (elt h j)
                             (make-indicator (elt (column-list e) j)
                                             (elt active-categories j))))
                             (y (make-category-quantifications z g))
                             (d (make-discrimination-measures y g)))
                      (send self :d-m d))))))
                 
  	  (add-text *homals-report-window*
		(format nil "~%Converged....\n\n") :scroll t)
                 (return)))
       (progn
(add-text *homals-report-window* 
                     (format nil "~%Iteration ~4d, Loss ~,5f, Change ~,5f"
                 itel new-fit-0 new-fit-1)
                     :scroll t)
         (setf fit-0 new-fit-0)
         (setf fit-1 new-fit-1)
         (setf itel (1+ itel))
         (setf x z)))))))


